package Zim::Repository::File;

use strict;
use POSIX qw(strftime);
use Encode;
use IO::File;
use File::Spec;
use File::Copy;
use File::MimeInfo;
use Zim::Repository::Base;
use Zim::Page::Text;

our $VERSION = '0.12';
our @ISA = qw/Zim::Repository::Base/;

my $case_tolerant_fs = File::Spec->case_tolerant();

=head1 NAME

Zim::Repository::File - A file system based repository

=head1 DESCRIPTION

This module implements a file system based repository for zim.
See L<Zim::Repository> for the interface documentation.

=head1 METHODS

=over 4

=item new(NAMESPACE, DIR)

Simple constructor. DIR is the root directory of the repository.
NAMESPACE is the namespace that maps to that directory.

=cut

sub init { # called by new
	my ($self, $dir, $format) = @_;
	
	$dir = File::Spec->rel2abs($dir);
	$self->{dir} = $dir;
	$self->{format} = $format || 'wiki';
	
	$self->{ext} = ($self->{format} eq 'wiki') ? 'txt' : 'html';
		# FIXME HACK FIXME - this belongs in a Formats.pm
	
	return $self;
}

=item list_pages(NAMESPACE)

=cut

sub list_pages {
	my ($self, $namespace) = @_;
	
	my $dir = $self->filename($namespace, 'DIR');
	#print "list pages $namespace => $dir\n";
	return () unless -d $dir;
	opendir DIR, $dir or die "Could not list dir $dir\n";
	my @items = grep {defined $_} map {
		my $item = File::Spec->catfile($dir, $_);
		if (-d $item) { s/(_files)?$/:/ }
		else {
			if (mimetype($item) =~ /^text/) { s/\.$$self{ext}$// }
			else { $_ = undef }
		}
		Encode::decode_utf8($_, 1);
	} grep {! /^\./} readdir DIR;
	closedir DIR;
	
	@items = sort {lc($a) cmp lc($b)} @items;
	for (0 .. $#items) { # cut doubles due to directories
		$items[$_] = undef if $items[$_+1] eq $items[$_].':' ;
	}
	return grep {defined $_} @items;
}

=item get_page(PAGE_NAME)

Returns an object of the type L<Zim::Page::Text>.

=cut

sub get_page {
	my ($self, $name, $source) = @_; # source is a private argument

	my $page = Zim::Page::Text->new($self, $name);
	$source ||= [ $self->filename($name) ]; # case sensitive lookup
	$page->set_source($source);
	$page->set_format($self->{format});
	$page->properties->{base} = 'file://'.$source->[1];
	
	unless (-f $$source[0]) {
		$page->{parse_tree} = $self->_template($page);
		$page->status('new');
	}

	return $page;
}

=item C<resolve_page(NAME)>

Like C<get_page()> but with case in-sensitive lookup for a page name.

=cut

sub resolve_page {
	my ($self, $name) = @_;
	$name =~ s/[^\w\.\:\-]/_/g;
	my ($file, $dir) = $self->filename($name, 0, 1); # case tolerant lookup
	my $page = $self->pagename($file);
	#warn "Resolved page: $name => $file => $page\n";
	$self->get_page($page);
}

sub _template {
	# FIXME make template configurable
	my ($self, $page) = @_;
	$page->name =~ /([^:]+):*$/;
	my $title = ucfirst($1);
	my $date = Encode::decode_utf8(
		strftime('%A %d/%m/%Y %H:%M', localtime), 1 );
	return	['Document', {},
			['head1', {}, $title],
			['Para',  {empty_lines => 1}, "Created $date\n"]
		];
}

=item copy_page(SOURCE, TARGET)

=cut

sub copy_page {
	my ($self, $old, $new) = @_;
	my ($old_file, $old_dir) = $self->filename($old);
	my ($new_file, $new_dir) = $self->filename($new);
	_mkdir($new_dir);
	copy($old_file, $new_file)
		or die "Could not move file $old_file to $new_file\n"
		if -f $old_file;
	@$new{'status', 'parse_tree'} = ('', undef);
}

=item move_page(SOURCE, TARGET)

=cut

sub move_page {
	my ($self, $old, $new) = @_;
	
	# Move file
	my ($old_file, $old_dir) = $self->filename($old);
	my ($new_file, $new_dir) = $self->filename($new);
	_mkdir($new_dir);
	move($old_file, $new_file)
		or die "Could not move file $old_file to $new_file\n"
		if -f $old_file;

	# Move tree below file
	my $old_tree = $self->filename($old, 'DIR');
	my $new_tree = $self->filename($new, 'DIR');
	move($old_tree, $new_tree)
		or die "Could not move dir $old_tree to $new_tree\n"
		if -d $old_tree;
	_rmdir($old_dir);

	# update objects
	@$new{'status', 'parse_tree'} = ('', undef)        if ref $new;
	@$old{'status', 'parse_tree'} = ('deleted', undef) if ref $old;
}

=item delete_page(PAGE)

=cut

sub delete_page {
	my ($self, $page) = @_;

	my ($file, $dir) = $self->filename($page);
	if (-f $file) {
		unlink $file or die "Could not remove file $file\n";
	}
	else {
		my $name = ref($page) ? $page->name : $page ;
		$dir = $self->filename($name, 'DIR');
	}
	_rmdir($dir); # fails silently when dir is not empty
	
	@$page{'status', 'parse_tree'} = ('deleted', undef) if ref $page;
}

=back

=head2 Private methods

=over 4

=item filename(PAGE, DIR, CASE)

Gives the filename corresponding to a page name.

DIR is a boolean that can be set to tell that PAGE is expected to
be a directory, which is useful when looking up a namespace.
This behaviour is also triggered if the page name ends with ':'.

CASE is a boolean that triggers a case in-sensitive lookup when true.

In list context the filename and directory for PAGE are returned.

=cut

sub filename {
	my ($self, $page, $is_dir, $case_tolerant) = @_;

	if (ref $page) { # page object
		return wantarray ? (@{$page->{source}}) : $page->{source}[0]
			if defined $page->{source};
		$page = $page->name;
	}
	
	$page =~ s/^:*$self->{namespace}:*//i;
	$is_dir++ if $page =~ s/:+$//;
	
	my @dirs = split /:+/, $page;
	my $basename = pop @dirs unless $is_dir;

	# Find the right dir
	my $dir = File::Spec->catdir($self->{dir}, @dirs);
	unless (!$case_tolerant_fs and  -d $dir) {
		$dir = $self->{dir};
		for (0 .. $#dirs) {
			my $new_dir = $self->_grep_dir(
				$dir, $dirs[$_], 1, $case_tolerant );
			if (defined $new_dir) { $dir = $new_dir }
			else {
				$dir = File::Spec->catdir($dir, @dirs[$_ .. $#dirs]);
				last;
			}
		}
	}
	
	if ($is_dir) {
		return $dir unless wantarray;
		@dirs = File::Spec->splitdir($dir);
		pop @dirs;
		my $parent = File::Spec->catdir(@dirs);
		#warn "resolved $page to dir $dir\n";
		return ($dir, $parent);
	}

	# Check the filename
	my $file = $self->_grep_dir($dir, $basename, 0, $case_tolerant);
	$file = File::Spec->catfile($dir, $basename .'.'.$$self{ext})
		unless defined $file;

	#warn "resolved $page to file $file\n";
	return wantarray ? ($file, $dir) : $file;
}

sub _grep_dir { # find a file or subdir
	my ($self, $dir, $basename, $is_dir, $case_tolerant) = @_;
	return undef unless -d $dir;
	my $extended = $basename . ($is_dir ? '_files' : '.'.$$self{ext});
	my $wrong_type = 0;
	
	unless ($case_tolerant and $case_tolerant_fs) {
		if ($is_dir) {
			my $path = File::Spec->catdir($dir, $basename);
			return $path if -d $path;
			$wrong_type = 1 if -e _;
		}
		else {
			my $path = File::Spec->catfile($dir, $basename);
			return $path if -f $path;
			$wrong_type = 1 if -e _;
		}
	
		my $path = $is_dir
			? File::Spec->catdir($dir, $extended)
			: File::Spec->catfile($dir, $extended) ;
		return $path if $wrong_type or -e $path;
		return undef unless $case_tolerant;
	}
	
	my @check = (lc($basename), lc($extended));
	my $suggestion;
	my $other_type = lc $basename . ($is_dir ? '.'.$$self{ext} : '_files');
	opendir DIR, $dir or die "Could not list dir $dir\n";
	while (my $item = readdir DIR) { 
		# FIXME for case_tolerant_fs it would be nicer to check
		# case sensitive version first in the listing
		$item = Encode::decode_utf8($item, 1);
		if (grep {$_ eq lc($item)} @check) {
			if ($is_dir) {
				$item = File::Spec->catdir($dir, $item);
				unless (-d $item) {
					$suggestion = $item;
					next;
				}
			}
			else {
				$item = File::Spec->catfile($dir, $item);
				unless (-f $item) {
					$suggestion = $item;
					next;
				}
			}
			closedir DIR;
			return $item;
		}
		elsif (lc($item) eq $other_type) {
			$suggestion = $is_dir
				? File::Spec->catdir($dir, $item)
		       		: File::Spec->catfile($dir, $item) ;
		}
	}
	closedir DIR;

	if ($suggestion) {
		if ($is_dir) { $suggestion =~ s/\.$$self{ext}$//          }
		else         { $suggestion =~ s/(_files)?$/\.$$self{ext}/ }
		return $suggestion;
	}
	
	return undef;
}

=item pagename(FILE)

Returns the page name corresponding to FILE. FILE does not actually
need to exist and can be a directory as well as a file.

=cut

sub pagename {
	my ($self, $file) = @_;
	$file = File::Spec->abs2rel($file, $self->{dir})
		if File::Spec->file_name_is_absolute($file);
	my @parts = map {s/_files$//; $_} grep length($_), File::Spec->splitdir($file);
	$parts[-1] =~ s/\.$$self{ext}$//;
	return $self->{namespace} . join ':', @parts;
}

=item C<get_source(SOURCE, MODE)>

Returns an IO::File object.

=cut

sub get_source {
	my ($self, $source, $mode) = @_;
	my $io;
	if ($mode eq 'r') { $io = IO::File->new($$source[0], 'r') }
	elsif ($mode eq 'w') {
		#print "get IO object for $$source[0]\n";
		_mkdir($$source[1]) unless -e $$source[1];
		$io = IO::File->new($$source[0], 'w');
	}
	else { die "unknown mode: $mode" }
	
	binmode $io, ':utf8' if defined $io and not $] < 5.008;
		# IO::File OO version broken in perl 5.8.7
	return $io;
}

# Methods below for filesystem interaction - subtle differences with File::Path

sub _mkdir {
	my ($dir, $file) = @_; # if $file is true $dir is a file
	my ($vol, $dirs) = File::Spec->splitpath($dir, $file ? 0 : 1);
	my @dirs = File::Spec->splitdir($dirs);
	my $path = File::Spec->catpath($vol, shift @dirs);
	mkdir $path or die "Could not create dir $path\n"
		if length $path and ! -d $path;
	while (@dirs) {
		$path = File::Spec->catdir($path, shift @dirs);
		mkdir $path or die "Could not create dir $path\n"
			unless -d $path;
	}
}

sub _rmdir {
	my $dir = shift;
	#print STDERR "rmdir $dir\n";
	rmdir $dir or return; # fails when non-empty
	my ($vol, $dirs) = File::Spec->splitpath($dir, 1);
	my @dirs = File::Spec->splitdir($dirs);
	while (@dirs) {
		pop @dirs;
		$dir = File::Spec->catdir($vol, @dirs);
		#print STDERR "rmdir $dir\n";
		rmdir $dir or last; # fails when non-empty
	}
}

1;

__END__

=back

=head1 BUGS

Please mail the author if you find any bugs.

=head1 AUTHOR

Jaap Karssenberg || Pardus [Larus] E<lt>pardus@cpan.orgE<gt>

Copyright (c) 2005 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<Zim>, L<Zim::Page>

=cut
